home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _fe3572da52942b0f2f46aa43752b6ec3 < prev    next >
Encoding:
Text File  |  2002-05-27  |  6.2 KB  |  207 lines
  1. package PPM::Compat;
  2. $VERSION = '3.00';
  3.  
  4. use strict;
  5. use Data::Dumper;
  6. use XML::Parser;
  7.  
  8. use constant PPM_PORT_PERL => 14533;
  9.  
  10. sub read_ppm_xml {
  11.     my ($file, $conf, $reps, $inst, $cmd, $extra) = @_;
  12.     my $parser = XML::Parser->new(Style => 'Tree');
  13.     my $tree   = $parser->parsefile($file);
  14.  
  15.     die "Error: node PPMCONFIG not found in ppm.xml"
  16.       unless $tree->[0] eq 'PPMCONFIG';
  17.     $tree = $tree->[1];
  18.  
  19.     my $parse_elem = sub {
  20.         my $ref = shift;
  21.         my $tree = shift;
  22.         my $key = shift;
  23.         my $req = shift;
  24.         my $content = shift; $content = 2 unless defined $content;
  25.         my $cref = shift;
  26.         my $i;
  27.         for ($i=0; $i<@$tree; $i++) { last if $tree->[$i] eq $key }
  28.         die "error: missing $key element in ppm.xml"
  29.       if $req && $i >= @$tree;
  30.         return if $i >= @$tree;
  31.         $cref->($ref, $key, $content, $tree->[$i+1]) if $cref;
  32.         $ref->{$key} = $tree->[$i+1][$content] unless $cref;
  33.     };
  34.  
  35.     my $parse_attr = sub {
  36.         my $ref = shift;
  37.         my $tree = shift;
  38.         my $key = shift;
  39.         my $req = shift;
  40.         my $keephash = shift;
  41.         my $cref = shift;
  42.         die "error: missing $key attribute in ppm.xml" 
  43.           if $req && not exists $tree->[0]{$key};
  44.         $cref->($ref, $key, $keephash, $tree->[0]{$key}) if $cref;
  45.         $ref->{$key} = $keephash ? $tree->[0] : $tree->[0]{$key} unless $cref;
  46.     };
  47.  
  48.     $inst->{PPMPRECIOUS} = [];
  49.     $parse_elem->($inst, $tree, 'PPMPRECIOUS', 0);
  50.     for (split ';', $inst->{PPMPRECIOUS}) {
  51.     push @{$inst->{precious}}, $_;
  52.     }
  53.     delete $inst->{PPMPRECIOUS};
  54.  
  55.     for (my $i=0; $i<@$tree; $i++) {
  56.     my $k = $tree->[$i];
  57.     my $v = $tree->[$i+1];
  58.     if ($k eq 'OPTIONS') {
  59.         my $tmp = $^O eq 'MSWin32' ? 'C:\Temp' : '/tmp';
  60.         @$conf{qw(BUILDDIR DOWNLOADSTATUS)} = ($tmp, 16384);
  61.         $parse_attr->($conf, $v, 'BUILDDIR', 0);
  62.         $parse_attr->($conf, $v, 'DOWNLOADSTATUS', 0);
  63.         @$conf{qw(tempdir downloadbytes)} =
  64.           ($conf->{BUILDDIR}, $conf->{DOWNLOADSTATUS});
  65.         delete @$conf{qw(BUILDDIR DOWNLOADSTATUS)};
  66.  
  67.         $cmd->{IGNORECASE} = 1;
  68.         $parse_attr->($cmd, $v, 'IGNORECASE', 0);
  69.         $cmd->{'case-sensitivity'} = $cmd->{IGNORECASE} ? '0' : '1';
  70.         delete $cmd->{IGNORECASE};
  71.  
  72.         $inst->{ROOT} = '';
  73.         $parse_attr->($inst, $v, 'ROOT', 0);
  74.         $inst->{root} = $inst->{ROOT} if $inst->{ROOT};
  75.         delete $inst->{ROOT};
  76.  
  77.         $parse_attr->($extra, $v, 'CLEAN', 0);
  78.         $parse_attr->($extra, $v, 'CONFIRM', 0);
  79.         $parse_attr->($extra, $v, 'FORCEINSTALL', 0);
  80.         $parse_attr->($extra, $v, 'MORE', 0);
  81.         $parse_attr->($extra, $v, 'TRACE', 0);
  82.         $parse_attr->($extra, $v, 'TRACEFILE', 0);
  83.         $parse_attr->($extra, $v, 'VERBOSE', 0);
  84.     }
  85.     elsif ($k eq 'PLATFORM') {
  86.         @$inst{qw(CPU OSVALUE OSVERSION)} = ('x86', $^O, '0,0,0,0');
  87.         $parse_attr->($inst, $v, 'CPU', 0);
  88.         $parse_attr->($inst, $v, 'OSVALUE', 1);
  89.         $parse_attr->($inst, $v, 'OSVERSION', 0);
  90.     }
  91.     elsif ($k eq 'REPOSITORY') {
  92.         my %r;
  93.         $parse_attr->(\%r, $v, 'LOCATION', 1);
  94.         $parse_attr->(\%r, $v, 'NAME', 1);
  95.         $parse_attr->(\%r, $v, 'USERNAME', 0);
  96.         $parse_attr->(\%r, $v, 'PASSWORD', 0);
  97.         fix_location(\$r{LOCATION});
  98.         
  99.         $reps->{$r{NAME}} = {
  100.         url => $r{LOCATION},
  101.         (defined $r{USERNAME} ? (username => $r{USERNAME}) : ()),
  102.         (defined $r{PASSWORD} ? (password => $r{PASSWORD}) : ()),
  103.         };
  104.     }
  105.     elsif ($k eq 'PACKAGE') {
  106.         my %r;
  107.         $parse_attr->(\%r, $v, 'NAME', 1);
  108.         $parse_elem->(\%r, $v, 'LOCATION', 1);
  109.         $parse_elem->(\%r, $v, 'INSTPACKLIST', 1);
  110.         $parse_elem->(\%r, $v, 'INSTROOT', 1);
  111.         $parse_elem->(\%r, $v, 'INSTDATE', 1);
  112.         fix_location(\$r{LOCATION});
  113.  
  114.         # Regenerates the PPD: I wish XML::Parser could do this...
  115.         my $cb = sub {
  116.         my ($ref, $key, $index, $tree) = @_;
  117.         my $i;
  118.         for ($i=0; $i<@$tree; $i++) { last if $tree->[$i] eq 'SOFTPKG' }
  119.             my $ppd = generate_ppd($tree->[$i], $tree->[$i+1]);
  120.         $ref->{ppd} = $ppd if $ppd;
  121.         };
  122.         $parse_elem->(\%r, $v, 'INSTPPD', 1, 2, $cb);
  123.         next if ($r{NAME} eq 'libwin32' and $^O ne 'MSWin32');
  124.         $inst->{$r{NAME}} = \%r;
  125.     }
  126.     }
  127. }
  128.  
  129. sub repository {
  130.     my $rep  = shift;
  131.     my %reps = (
  132.     ppm3 => 'http://ppm-ia.ActiveState.com/PPM/ppmserver.plex?urn:/PPM/Server/SQL',
  133.     ppm2 => 'http://ppm.ActiveState.com/cgibin/PPM/ppmserver.pl?urn:/PPMServer',
  134.     www  => 'http://ppm.ActiveState.com/PPMPackages/5.6',
  135.     );
  136.     return $reps{$rep};
  137. }
  138.  
  139. sub fix_location {
  140.     my $ref = shift;
  141.     if ($$ref =~ m{^soap://}i and $$ref =~ m{ActiveState}) {
  142.     $$ref = repository('www');
  143.     }
  144.     $$ref =~ s{soap://}{http://}i;
  145.     if ($$ref =~ m[ActiveState.com/cgibin/PPM/ppmserver.pl\?]i) {
  146.     $$ref = repository('ppm3');
  147.     }
  148. }
  149.  
  150. sub generate_ppd {
  151.     my $tagname = shift;
  152.     my $tree    = shift;
  153.     my $ppd     = _generate_ppd($tagname, $tree);
  154.     return qq{<?xml version="1.0" encoding="UTF-8"?>\n$ppd};
  155. }
  156. sub _generate_ppd {
  157.     my $tagname = shift;
  158.     my $tree    = shift;
  159.     return undef unless $tagname;
  160.     my @lines;
  161.     my $line = '<' . $tagname;
  162.     if (%{$tree->[0] || {}}) {
  163.     for my $key (keys %{$tree->[0]}) {
  164.         my $val = $tree->[0]{$key};
  165.         $line .= qq{ $key="$val"};
  166.     }
  167.     }
  168.     $line .= '>';
  169.     $line .= xml_encode(ref($tree->[2]) ? "\n" : $tree->[2]);
  170.     push @lines, $line;
  171.     my $start = ref($tree->[2]) ? 1 : 3;
  172.     for (my $j=$start; $j<@$tree; $j++) {
  173.         next unless $tree->[$j] =~ /^[A-Z]+$/;
  174.     push @lines, _generate_ppd($tree->[$j], $tree->[$j+1]);
  175.     }
  176.     push @lines, "</$tagname>\n";
  177.     wantarray ? @lines : join '', @lines;
  178. }
  179.  
  180. sub xml_encode {
  181.     local $_ = shift || '';
  182.     s/</</g;
  183.     s/>/>/g;
  184.     $_;
  185. }
  186.  
  187. sub batchify {
  188.     my $exe = shift;
  189.     my $perl = shift || $^X;
  190.     my $batch = $exe;
  191.     $batch =~ s/\.PL$//;
  192.     $batch =~ s/\.pl$//;
  193.     if ($^O eq 'MSWin32') {
  194.         $batch .= '.bat';
  195.     }
  196.     # A bug in system() forces us to convert $exe to an 8.3 pathname on
  197.     # Windows. Presumably there is no workaround in Unix.
  198.     if ($^O eq 'MSWin32') {
  199.         require Win32;
  200.         $exe = Win32::GetShortPathName($exe);
  201.     }
  202.     system($perl, $exe, @_);
  203.     unlink($exe) || die "can't delete $exe: $!";
  204.     return $batch;
  205. }
  206.  
  207.